perm filename SMACRO.LSP[SCH,LSP] blob
sn#688845 filedate 1982-11-14 generic text, type C, neo UTF8
COMMENT ā VALID 00006 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 -*-LISP-*-
C00004 00003
C00006 00004
C00010 00005
C00014 00006
C00017 ENDMK
Cā;
;;; -*-LISP-*-
;;;; abstract syntax and data-structures access macros for SCODE
;;; We define the data-structures used by the run-time system in terms
;;; of the following abstraction macros.
#M(DECLARE (MACROS T))
(DEFMACRO TYPE (EXP) `(CAR ,EXP))
(DEFMACRO BODY (EXP) `(CDR ,EXP))
(DEFMACRO MAKE-EXPRESSION (TYPE BODY)
`(CONS ,TYPE ,BODY))
(DEFMACRO TEXT-OF-QUOTATION (EXP) `(CADR ,EXP))
(DEFMACRO DELAYED-CORPUS (EXP) `(CADR ,EXP))
;;; Conditionals
(DEFMACRO TRUE? (X) `(NOT (NULL ,X)))
;;; If-then-else
(DEFMACRO ALTERNATIVES (EXP) `(CDDR ,EXP))
(DEFMACRO PREDICATE-PART (EXP) `(CADR ,EXP))
(DEFMACRO CONSEQUENT (ALTS) `(CAR ,ALTS))
(DEFMACRO ALTERNATIVE (ALTS) `(CADR ,ALTS))
(DEFMACRO NO-ALTERNATIVE? (ALTS) `(NULL (CDR ,ALTS)))
;;; Unless
(DEFMACRO UNLESS-FIRST (EXP) `(CADR ,EXP))
(DEFMACRO UNLESS-SECOND (EXP) `(CADDR ,EXP))
;;; Combinations and sequences of expressions
(DEFMACRO EXPRESSIONS (COMB) `(CDR ,COMB))
(DEFMACRO LAST-EXP? (SEQ) `(NULL (CDR ,SEQ)))
(DEFMACRO FIRST-EXP (SEQ) `(CAR ,SEQ))
(DEFMACRO REST-EXPS (SEQ) `(CDR ,SEQ))
(DEFMACRO LAST-EXP (SEQ) `(CAR (LAST ,SEQ)))
;;; A lexical variable may be one of the following types:
;;; (LEXICAL-UNCOMPILED . <name>)
;;; (LEXICAL-FORMAL . <formal varspec>)
;;; (LEXICAL-AUXILIARY . <aux varspec>)
;;; (GLOBAL . <name>)
(DEFMACRO VARSPEC (EXP) `(CDR ,EXP))
(DEFMACRO REPLACE-VARIABLE-TYPE (VAR NEW) `(RPLACA ,VAR ,NEW))
(DEFMACRO REPLACE-VARSPEC (VAR NEW) `(RPLACD ,VAR ,NEW))
;;; (ASSIGN-UNCOMPILED <value> . <name>)
;;; (ASSIGN-FORMAL <value> . <formal varspec>)
;;; (ASSIGN-AUXILIARY <value> . <aux varspec>)
;;; (ASSIGN-GLOBAL <value> . <name>)
(DEFMACRO ASSIGN-VALUE (EXP) `(CADR ,EXP))
(DEFMACRO ASSIGN-VARSPEC (EXP) `(CDDR ,EXP))
(DEFMACRO REPLACE-ASSIGN-VARSPEC (EXP NEW) `(RPLACD (CDR ,EXP) ,NEW))
;;; <varspec> = (<lexical address> . (<name> . <env ident>))
;;; for formal varspecs <env ident> is NIL.
(DEFMACRO MAKE-VARSPEC (FN DN VAR ENV-IDENT)
`(CONS (CONS ,FN ,DN) (CONS ,VAR ,ENV-IDENT)))
(DEFMACRO LEXICAL-ADDRESS (VSPEC) `(CAR ,VSPEC))
(DEFMACRO VARIABLE-NAME (VSPEC) `(CADR ,VSPEC))
(DEFMACRO ENVIRONMENT-IDENTIFIER (VSPEC) `(CDDR ,VSPEC))
;;; <lexical address> = (<frame number> <displacement number>)
(DEFMACRO FRAME-NUMBER (LA) `(CAR ,LA))
(DEFMACRO DISPLACEMENT-NUMBER (LA) `(CDR ,LA))
;;; SCHEME extended objects are implemented as hunks with cxr 1 holding the
;;; object type.
(DEFMACRO OBJECT-TYPE (OBJECT) `(CXR 1 ,OBJECT))
(DEFMACRO MAKE-PRIMITIVE-PROCEDURE (CLASS OBJECT ARGS SYMBOL)
`(MAKE-HUNK ,CLASS ,OBJECT ,SYMBOL ,ARGS))
(DEFMACRO PRIMITIVE-PROCEDURE? (OBJECT)
`(AND (HUNKP ,OBJECT)
(MEMQ (PROCEDURE-CLASS ,OBJECT)
'(SUBR LSUBR UNFORCED-SUBR UNFORCED-LSUBR BUT-1-FORCED-SUBR EXPR))))
;;; Compound procedure definitions (procedure-definition <bvars> . <body>)
;;; become closures: (*procedure* . (<bvars> . <body>) . <name> . <env>)
(DEFMACRO MAKE-PROCEDURE (DEF ENV)
`(MAKE-HUNK '*PROCEDURE* (CDR ,DEF) NIL ,ENV))
(DEFMACRO APPLICABLE? (OBJECT)
`(AND (HUNKP ,OBJECT)
(MEMQ (PROCEDURE-CLASS ,OBJECT)
'(SUBR LSUBR UNFORCED-SUBR *PROCEDURE* UNFORCED-LSUBR
BUT-1-FORCED-SUBR EXPR *CONTROL-POINT* *EVALUATOR*))))
(DEFMACRO PROCEDURE-CLASS (PROC) `(CXR 1 ,PROC))
(DEFMACRO PROCEDURE-OBJECT (PROC) `(CXR 2 ,PROC))
(DEFMACRO PROCEDURE-NAME (PROC) `(CXR 3 ,PROC))
(DEFMACRO SET-PROCEDURE-CLASS (PROC CLASS) `(RPLACX 1 ,PROC ,CLASS))
(DEFMACRO SET-PROCEDURE-OBJECT (PROC OBJECT) `(RPLACX 2 ,PROC ,OBJECT))
(DEFMACRO SET-PROCEDURE-NAME (PROC NAME) `(RPLACX 3 ,PROC ,NAME))
;;; For primitive procedures the ARGS property is in the 0 slot.
(DEFMACRO PROCEDURE-ARGS (PROC) `(CXR 0 ,PROC))
(DEFMACRO SET-PROCEDURE-ARGS (PROC ARGS) `(RPLACX 0 ,PROC ,ARGS))
;;; For compound procedures, the environment is in the 0 slot.
(DEFMACRO PROCEDURE-ENVIRONMENT (PROC) `(CXR 0 ,PROC))
(DEFMACRO SET-PROCEDURE-ENVIRONMENT (PROC ENV) `(RPLACX 0 ,PROC ,ENV))
(DEFMACRO FORMAL-PARAMETERS (PROC) `(CAR (PROCEDURE-OBJECT ,PROC)))
(DEFMACRO PROCEDURE-BODY (PROC) `(CDR (PROCEDURE-OBJECT ,PROC)))
(DEFMACRO MAKE-CONTROL-BINDER-PROCEDURE (DEF ENV)
`(MAKE-HUNK '*CONTROL-BINDER* (CDR ,DEF) NIL ,ENV))
(DEFMACRO CONTROL-BINDER-BODY (DEF) `(CDDR ,DEF))
;;; (dynamic-wind <entry-form> <content-form> <exit-form>)
(DEFMACRO ENTRY-FORM (EXP) `(CADR ,EXP))
(DEFMACRO CONTENT-FORM (EXP) `(CADDR ,EXP))
(DEFMACRO EXIT-FORM (EXP) `(CADDDR ,EXP))
(DEFMACRO WIND-FORM (X) `(ENTRY-FORM (CAR ,X)))
(DEFMACRO UNWIND-FORM (X) `(EXIT-FORM (CAR ,X)))
(DEFMACRO DYNAMIC-ENV (X) `(CDR ,X))
;;; environment = (*ENVIRONMENT* . <procedure> . <args> . <arg-flags>
;;; . <aux-vars> . <aux-vals> . <aux-flags>
;;; . <potentially-dangerous-vars>)
(DEFMACRO MAKE-ENVIRONMENT (PROC ARGL)
`(MAKE-HUNK '*ENVIRONMENT* ,PROC ,ARGL NIL NIL NIL NIL NIL))
(DEFMACRO GLOBAL-ENVIRONMENT? (OBJECT) `(NULL ,OBJECT))
(DEFMACRO FRAME? (OBJECT)
`(AND (HUNKP ,OBJECT)
(EQ (OBJECT-TYPE ,OBJECT) '*ENVIRONMENT*)))
(DEFMACRO ENVIRONMENT? (OBJECT)
`(OR (GLOBAL-ENVIRONMENT? ,OBJECT)
(FRAME? ,OBJECT)))
(DEFMACRO FRAME-PROCEDURE (ENV) `(CXR 2 ,ENV))
(DEFMACRO FRAME-ARGUMENTS (ENV) `(CXR 3 ,ENV))
(DEFMACRO FRAME-FLAGS (ENV) `(CXR 4 ,ENV))
(DEFMACRO SET-FRAME-FLAGS (ENV NEWFLAGS) `(RPLACX 4 ,ENV ,NEWFLAGS))
(DEFMACRO AUX-VARIABLES (ENV) `(CXR 5 ,ENV))
(DEFMACRO SET-AUX-VARIABLES (ENV NEWVARS) `(RPLACX 5 ,ENV ,NEWVARS))
(DEFMACRO AUX-VALUES (ENV) `(CXR 6 ,ENV))
(DEFMACRO SET-AUX-VALUES (ENV NEWVALUES) `(RPLACX 6 ,ENV ,NEWVALUES))
(DEFMACRO AUX-FLAGS (ENV) `(CXR 7 ,ENV))
(DEFMACRO SET-AUX-FLAGS (ENV NEWFLAGS) `(RPLACX 7 ,ENV ,NEWFLAGS))
(DEFMACRO POTENTIALLY-DANGEROUS-VARIABLES (ENV) `(CXR 0 ,ENV))
(DEFMACRO SET-POTENTIALLY-DANGEROUS-VARIABLES (ENV NEWVARS)
`(RPLACX 0 ,ENV ,NEWVARS))
(DEFMACRO FRAME-FORMALS (ENV) `(FORMAL-PARAMETERS (FRAME-PROCEDURE ,ENV)))
(DEFMACRO PREVIOUS-FRAME (ENV) `(PROCEDURE-ENVIRONMENT (FRAME-PROCEDURE ,ENV)))
(DEFMACRO POTENTIALLY-DANGEROUS? (VAR ENV)
`(MEMQ ,VAR (POTENTIALLY-DANGEROUS-VARIABLES ,ENV)))
(DEFMACRO MAKE-POTENTIALLY-DANGEROUS (VAR ENV)
`(IF (POTENTIALLY-DANGEROUS? VAR ENV)
NIL
(SET-POTENTIALLY-DANGEROUS-VARIABLES ,ENV
(CONS ,VAR (POTENTIALLY-DANGEROUS-VARIABLES ,ENV)))))
(DEFMACRO REMOVE-FROM-POTENTIALLY-DANGEROUS (VAR ENV)
`(SET-POTENTIALLY-DANGEROUS-VARIABLES ,ENV
(DELQ ,VAR (POTENTIALLY-DANGEROUS-VARIABLES ,ENV))))
(DEFMACRO DANGEROUS? (FLAGS)
`(MEMQ 'DANGEROUS ,FLAGS))
(DEFMACRO GLOBAL-VCELL (SYMBOL)
`(GET ,SYMBOL 'SCHEME-GLOBAL-VALUE))
(DEFMACRO SET-GLOBAL-VALUE (SYMBOL VAL)
`(LET ((VC (GLOBAL-VCELL ,SYMBOL)))
(IF (NULL VC)
(PUTPROP ,SYMBOL (CONS ,VAL NIL) 'SCHEME-GLOBAL-VALUE)
(RPLACA VC ,VAL))))
(DEFMACRO GLOBAL-FLAGS (SYMBOL)
`(GET ,SYMBOL 'SCHEME-GLOBAL-FLAGS))
(DEFMACRO SET-GLOBAL-FLAGS (SYMBOL FLAGS)
`(PUTPROP ,SYMBOL ,FLAGS 'SCHEME-GLOBAL-FLAGS))
(DEFMACRO GLOBALLY-BOUND? (SYMBOL)
`(GLOBAL-VCELL ,SYMBOL))
(DEFMACRO MAKE-DANGEROUS-GLOBAL (VAR)
`(LET ((VC (GLOBAL-VCELL ,VAR)))
(IF (NULL VC)
(PUTPROP ,VAR (CONS NIL T) 'SCHEME-GLOBAL-VALUE)
(RPLACD VC 'T))))
(DEFMACRO DANGEROUS-GLOBAL? (VC)
`(CDR ,VC))
;;; Value cells are accessed by the following:
(DEFMACRO INLOC (VCELL) `(CAR ,VCELL))
(DEFMACRO SETLOC (VCELL VAL) `(RPLACA ,VCELL ,VAL))
;;; Delayed objects are produced by MAKE-DELAYED.
(DEFVAR *NO-VALUE* (LIST '*NO-VALUE*))
(DEFMACRO MAKE-DELAYED (EXP ENV)
`(MAKE-HUNK '*DELAYED* ,EXP ,ENV *NO-VALUE*))
(DEFMACRO DELAYED? (OBJ)
`(AND (HUNKP ,OBJ) (EQ (OBJECT-TYPE ,OBJ) '*DELAYED*)))
(DEFMACRO DELAYED-EXPRESSION (OBJ) `(CXR 2 ,OBJ))
(DEFMACRO DELAYED-ENVIRONMENT (OBJ) `(CXR 3 ,OBJ))
(DEFMACRO FORCED-VALUE (OBJ) `(CXR 0 ,OBJ))
(DEFMACRO ALREADY-FORCED? (OBJ) `(NOT (EQ (FORCED-VALUE ,OBJ) *NO-VALUE*)))
(DEFMACRO SET-FORCED-VALUE (OBJ VALUE) `(RPLACX 0 ,OBJ ,VALUE))
;;; Arg list stuff
(DEFMACRO GET-ARG (ARGL) `(CAR ,ARGL))
(DEFMACRO SET-ARG (ARGL VALUE) `(RPLACA ,ARGL ,VALUE))
(DEFMACRO FIRST-ARGUMENT (ARGL) `(CAR ,ARGL))
(DEFMACRO SECOND-ARGUMENT (ARGL) `(CADR ,ARGL))